home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / printing.swg / 0041_EAN-8 & EAN-13 Barcode printing.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-02-28  |  8.9 KB  |  418 lines
  1. { This unit writes EAN-8 and EAN-13 barcodes to an Epson, IBM Pro or HP
  2.   Laser compatible printers. It has been tested on a variety of printers
  3.   and works well.  The barcodes generated were able to be read by at least
  4.   one brand of bar code reader.
  5.  
  6. By Rohit Gupta
  7.  
  8. You may use this as you see fit.
  9.  
  10. }
  11.  
  12. {$R-,B+,S-,I+,N-,D-,L-,Y-}
  13. {$M $4000,$4000,$8000}
  14.  
  15. UNIT BarCode;
  16.  
  17.  
  18. INTERFACE
  19.  
  20.  
  21. CONST
  22.      PrnPosn = 5;  { Print Offset Column }
  23.  
  24. TYPE
  25.     EAN_13  = STRING [13];
  26.  
  27.     Printer_Type = (Epson, Ibm, Laser);
  28.  
  29.  
  30. PROCEDURE Print_BarCode
  31.           (VAR Lst    : TEXT;
  32.                Typ    : Printer_Type;
  33.                Code   : EAN_13;
  34.                NLines : INTEGER);
  35.  
  36.  
  37. IMPLEMENTATION
  38.  
  39.  
  40. FUNCTION Num (Arg : INTEGER) : STRING;
  41. VAR
  42.    St : STRING [20];
  43. BEGIN
  44.      STR (Arg,St);
  45.      Num := St;
  46. END;
  47.  
  48.  
  49. PROCEDURE Print_BarCode (VAR Lst  : TEXT;   Typ    : Printer_Type;
  50.                              Code : EAN_13; NLines : INTEGER);
  51.  
  52. CONST
  53.      Max_Code_Len = 2*3 + 5 + 7*12;  { For 12 digit bar code }
  54.  
  55.      ESC = #27;
  56.  
  57.  
  58. TYPE
  59.     Bar_Position = (Left,Centre,Right);
  60.     One_Dig      = STRING [7];
  61.     Buffer       = ARRAY [1..1024] OF CHAR;
  62.  
  63.  
  64. VAR
  65.    LCode     : EAN_13;   { Local Copy, padded & checked }
  66.    Seg_Size,             { Left/Right Segment Size      }
  67.    Code_Len,             { Size of BarCode in digits    }
  68.    Bar_Len,              { Size of Barcode in bar units }
  69.    Bytes,                { Bytes per bar unit           }
  70.    Line_Len,             { Line Length in Gfx Mode      }
  71.    Mult      : INTEGER;  { Number of Lines per char line}
  72.  
  73.    Full_Code : STRING [Max_Code_Len];
  74.  
  75.    PBuffer   : ^Buffer;
  76.    Posn      : INTEGER;  { Buffer Position }
  77.  
  78.  
  79. PROCEDURE Rationalise_Code;
  80. VAR
  81.    I : INTEGER;
  82. BEGIN
  83.      IF LENGTH (Code) > 8
  84.      THEN Seg_Size := 6
  85.      ELSE Seg_Size := 4;
  86.  
  87.      Code_Len := Seg_Size * 2;
  88.  
  89.      LCode := Code;
  90.      FOR I := LENGTH(LCode)+1 TO Code_Len-1  { Pad with Leading Zeros }
  91.      DO LCode := '0' + LCode;
  92.  
  93.      Bar_Len := 2*3 + 5 + 7*Code_Len;
  94.              {  LRG   CG  CODE }
  95. END;
  96.  
  97.  
  98. PROCEDURE Calc_Check_Digit;
  99. VAR
  100.    I, C1 : INTEGER;
  101. BEGIN
  102.      IF Code_Len <> LENGTH(LCode)+1  { If already there, assume ok }
  103.      THEN EXIT;
  104.  
  105.      C1 := 0;
  106.      FOR I := Seg_Size DOWNTO 1
  107.      DO INC (C1,ORD(LCode[I*2-1])-$30);
  108.      C1 := C1 * 3;
  109.      FOR I := Seg_Size-1 DOWNTO 1
  110.      DO INC (C1,ORD(LCode[I*2])-$30);
  111.  
  112.      LCode := LCode + CHR (((10-(C1 MOD 10)) MOD 10) +$30);
  113. END;
  114.  
  115.  
  116. PROCEDURE Guard (Which : Bar_Position);
  117. VAR
  118.    Dig : One_Dig;
  119. BEGIN
  120.      CASE Which OF
  121.           Centre : Dig := '01010';
  122.           ELSE     Dig := '101';
  123.      END;
  124.      Full_Code := Full_Code + Dig;
  125. END;
  126.  
  127.  
  128. FUNCTION DigA (Arg : EAN_13) : One_Dig;
  129. VAR
  130.    Dig : One_Dig;
  131.    I   : INTEGER;
  132. BEGIN
  133.      FOR I := 1 TO LENGTH (Arg)
  134.      DO BEGIN
  135.         CASE Arg[I] OF
  136.              '9' : Dig := '0001011';
  137.              '8' : Dig := '0110111';
  138.              '7' : Dig := '0111011';
  139.              '6' : Dig := '0101111';
  140.              '5' : Dig := '0110001';
  141.              '4' : Dig := '0100011';
  142.              '3' : Dig := '0111101';
  143.              '2' : Dig := '0010011';
  144.              '1' : Dig := '0011001';
  145.              ELSE  Dig := '0001101';
  146.         END;
  147.         Full_Code := Full_Code + Dig;
  148.      END;
  149. END;
  150.  
  151.  
  152. PROCEDURE DigB (Arg : EAN_13);
  153. VAR
  154.    Dig : One_Dig;
  155.    I   : INTEGER;
  156. BEGIN
  157.      FOR I := 1 TO LENGTH (Arg)
  158.      DO BEGIN
  159.         CASE Arg[I] OF
  160.              '9' : Dig := '0010111';
  161.              '8' : Dig := '0001001';
  162.              '7' : Dig := '0010001';
  163.              '6' : Dig := '0111001';
  164.              '5' : Dig := '0111001';
  165.              '4' : Dig := '0011101';
  166.              '3' : Dig := '0100001';
  167.              '2' : Dig := '0011011';
  168.              '1' : Dig := '0110011';
  169.              ELSE  Dig := '0100111';
  170.         END;
  171.         Full_Code := Full_Code + Dig;
  172.      END;
  173. END;
  174.  
  175.  
  176. PROCEDURE DigC (Arg : EAN_13);
  177. VAR
  178.    Dig : One_Dig;
  179.    I   : INTEGER;
  180. BEGIN
  181.      FOR I := 1 TO LENGTH (Arg)
  182.      DO BEGIN
  183.         CASE Arg[I] OF
  184.              '9' : Dig := '1110100';
  185.              '8' : Dig := '1001000';
  186.              '7' : Dig := '1000100';
  187.              '6' : Dig := '1010000';
  188.              '5' : Dig := '1001110';
  189.              '4' : Dig := '1011100';
  190.              '3' : Dig := '1000010';
  191.              '2' : Dig := '1101100';
  192.              '1' : Dig := '1100110';
  193.              ELSE  Dig := '1110010';
  194.         END;
  195.         Full_Code := Full_Code + Dig;
  196.      END;
  197. END;
  198.  
  199.  
  200. PROCEDURE Compose_Code;
  201. BEGIN
  202.      Full_Code := '';
  203.      Guard (Left);
  204.      DigA  (COPY(LCode,1,Seg_Size));
  205.      Guard (Centre);
  206.      DigC  (COPY(LCode,Seg_Size+1,Seg_Size*2));
  207.      Guard (Right);
  208. END;
  209.  
  210.  
  211. PROCEDURE Init_Buffer;
  212. BEGIN
  213.      NEW (PBuffer);
  214.      FILLCHAR (PBUffer^,SIZEOF(PBuffer^),#0);
  215.      Posn := 0;
  216.  
  217.      CASE Typ OF
  218.           Epson : BEGIN
  219.                        Bytes    := 3*3; { 3 pixels x 24 pins }
  220.                        Line_Len := 3*Bar_Len;
  221.                        Mult     := 1;
  222.                   END;
  223.           Ibm   : BEGIN
  224.                        Bytes    := 4;     { 4 pixels X 8 pins }
  225.                        Line_Len := 4*Bar_Len;
  226.                        Mult     := 1;
  227.                   END;
  228.           ELSE    BEGIN
  229.                        Bytes    := 0;     { 5 pixels }
  230.                        Line_Len := (5*Bar_Len +7) DIV 8;
  231.                        Mult     := 37 * NLines;
  232.                        NLines   := 1;
  233.                   END;
  234.      END;
  235. END;
  236.  
  237.  
  238. PROCEDURE Send_Preamble;
  239. VAR
  240.    St : STRING [20];
  241. BEGIN
  242.      IF NLines <> 1
  243.      THEN BEGIN
  244.           CASE Typ OF
  245.                Epson : St := ESC+'0';
  246.                Ibm   : St := ESC+'3'#24;
  247.                ELSE    St := ESC+'&l8D';
  248.           END;
  249.           WRITE (Lst,St);
  250.      END;
  251. END;
  252.  
  253.  
  254. PROCEDURE Send_Postamble;
  255. BEGIN
  256.      IF NLines <> 1
  257.      THEN IF Typ = Laser
  258.           THEN WRITE (Lst,ESC,'&l6D')
  259.           ELSE WRITE (Lst,ESC,'2');
  260. END;
  261.  
  262.  
  263. PROCEDURE Send_Buffer;
  264. VAR
  265.    I : INTEGER;
  266. BEGIN
  267.      CASE Typ OF
  268.           Epson : WRITE (Lst,ESC,'*'#$27,CHR(Line_Len MOD 256),CHR(Line_Len DIV 256));
  269.           Ibm   : WRITE (Lst,ESC,'Z',CHR(Line_Len MOD 256),CHR(Line_Len DIV 256));
  270.           ELSE    WRITE (Lst,ESC,'*t300R',ESC,'*r1A',ESC,'*b',Line_Len,'W');
  271.      END;
  272.  
  273.      FOR I := 1 TO Posn
  274.      DO WRITE (Lst,PBuffer^[I]);
  275.  
  276.      CASE Typ OF
  277.           Laser : WRITE (Lst, ESC, '*rB');
  278.      END;
  279. END;
  280.  
  281.  
  282. PROCEDURE Compose_Buffer;
  283. VAR
  284.    I   : INTEGER;
  285.    Bar : CHAR;
  286.    Blk,
  287.    Spc : STRING [12];
  288.  
  289. PROCEDURE Add (St : STRING);
  290. BEGIN
  291.      MOVE (St[1],PBuffer^[Posn+1],LENGTH (St));
  292.      INC (Posn,LENGTH (St));
  293. END;
  294.  
  295. VAR
  296.    Frag, Len : INTEGER;
  297.  
  298. PROCEDURE Add_Frag (B : BYTE);
  299. BEGIN
  300.      Frag := (Frag SHL 5) OR (B AND $1F);
  301.      INC (Len,5);
  302.      IF Len >= 8
  303.      THEN BEGIN
  304.           Add (CHR (Frag SHR (Len-8)));
  305.           DEC (Len,8);
  306.      END;
  307. END;
  308.  
  309. PROCEDURE Add_Bar (Bar : CHAR);
  310. BEGIN
  311.      IF Typ = Laser        { 1-dot-line at a time }
  312.      THEN BEGIN
  313.           IF Bar = '0'
  314.           THEN Add_Frag (0)
  315.           ELSE Add_Frag ($1F);
  316.      END
  317.      ELSE BEGIN            { 8/24-dot-lines at a time }
  318.           IF Bar = '0'
  319.           THEN Add (Spc)
  320.           ELSE Add (Blk);
  321.      END;
  322. END;
  323.  
  324. BEGIN
  325.      Frag := 0;
  326.      Len  := 0;
  327.  
  328.      Blk := '';             { Compose the unit stripes }
  329.      Spc := '';
  330.      FOR I := 1 TO Bytes
  331.      DO BEGIN
  332.         Blk := Blk + #$FF;
  333.         Spc := Spc + #$00;
  334.      END;
  335.  
  336.      FOR I := 1 TO LENGTH (Full_Code)  { Compose Bars }
  337.      DO Add_Bar (Full_Code [I]);
  338.  
  339.      IF Typ = Laser
  340.      THEN WHILE Posn < Line_Len
  341.           DO Add_Bar ('0')
  342. END;
  343.  
  344.  
  345. VAR
  346.    I,J : INTEGER;
  347.  
  348. BEGIN
  349.  
  350.      Rationalise_Code;
  351.      Calc_Check_Digit;
  352.      Compose_Code;
  353.      Init_Buffer;
  354.      Compose_Buffer;
  355.  
  356.      Send_Preamble;
  357.  
  358.      FOR I := 1 TO NLines
  359.      DO BEGIN
  360.         WRITE (Lst,'':PrnPosn);
  361.         FOR J := 1 TO Mult
  362.         DO BEGIN
  363.            Send_Buffer;
  364.         END;
  365.         WRITELN (Lst);
  366.      END;
  367.  
  368.      Send_Postamble;
  369.      WRITELN (Lst,'':PrnPosn+2,LCode); WRITELN (Lst);
  370. END;
  371.  
  372.  
  373. END.
  374.  
  375. { ----------------------    TEST PROGRAM  ---------------------------------- }
  376.  
  377. USES
  378.     Crt, Barcode, Printer;
  379.  
  380.  
  381. VAR
  382. {  Lst : TEXT;}
  383.    Ch  : CHAR;
  384.    Typ : Printer_Type;
  385.  
  386. BEGIN
  387.      WRITELN;
  388.      WRITELN ('Bar Code Test');
  389.      WRITELN;
  390.  
  391.      WRITE ('Select Printer Type (E=Epson, I=IbmPro, L=HPLaser) ');
  392.  
  393.      Ch := UPCASE (READKEY);
  394.  
  395.      CASE Ch OF
  396.           'L' : Typ := Laser;
  397.           'I' : Typ := Ibm;
  398.           'E' : Typ := Epson;
  399.           ELSE EXIT;
  400.      END;
  401.  
  402. {    ASSIGN (Lst,'TEST');
  403.      REWRITE (Lst);}
  404.  
  405.      Print_BarCode (Lst,Typ,'1234567',    1);
  406.      Print_BarCode (Lst,Typ, '9876543',   1);
  407.      Print_BarCode (Lst,Typ,'12345678901',1);
  408.  
  409.      Print_BarCode (Lst,Typ,'1234567',    2);
  410.      Print_BarCode (Lst,Typ, '9876543',   2);
  411.      Print_BarCode (Lst,Typ,'12345678901',2);
  412.  
  413.      WRITE (Lst,#$0C);
  414.  
  415. {    CLOSE (Lst);}
  416. END.
  417.  
  418.